Shareware Grab Bag/Shareware Grab Bag.iso/090/byte0787.arc/IWPAS.ARC/PICTURES.P

Text File | 1987-04-28 | 14.3 KB | 519 lines

{ PICTURES.P -- picture file routines                   }

{ Copyright (c) 1987, Ciarcia's Circuit Cellar          }
{    All Rights Reserved                                }

{-------------------------------------------------------}
{ Dump a segmented address with a message               }

PROCEDURE DumpAddr(msg : strtype;
                   segment,offset : INTEGER);

BEGIN
 Writeln(msg,IntToHex(segment),':',
             IntToHex(offset));
END;


{-------------------------------------------------------}
{ Get file spec if not present                          }

FUNCTION GetFSpec(fn: strtype) : strtype;

BEGIN
 IF Length(fn) = 0              { if no file spec given }
  THEN BEGIN
   Write('Picture file name: ');
   Readln(fn);                  { get one               }
  END;

 GetFSpec := fn;                { else use given spec   }

END;

{-------------------------------------------------------}
{ Present message, return boolean response              }

FUNCTION Askit(msg : strtype) : BOOLEAN;

VAR
 resp      : STRING[5];

BEGIN
 Write(msg,' ');                { present question      }
 Readln(resp);                  { get some answer       }

 Askit := FALSE;
 IF Length(resp) <> 0           { categorize response   }
  THEN IF UpCase(resp[1]) = 'Y'
        THEN Askit := TRUE;

END;

{-------------------------------------------------------}
{ Allocate and initialize the picture buffer            }

PROCEDURE PicSetup(VAR newpic : picptr);

VAR
 pels      : pelrng;
 lines     : linerng;

BEGIN

 IF newpic <> NIL               { discard if allocated  }
  THEN Dispose(newpic);

 New(newpic);                   { allocate new array    }

END;


{-------------------------------------------------------}
{ Get a picture from the transmitter                    }
{ The bit rate depends on which PC you're using...      }
{ An 8 MHz AT can handle 28.8 K bits/sec                }
{ Sets RTS and DTR to switch the relay box before       }
{  taking the picture, restores normal display after    }
{ Some debugging statements are commented out... you    }
{  may need them to get your system running             }

PROCEDURE GetPicture(pic : picptr;
                     resol : BYTE);

VAR
 picbyte   : BYTE;              { byte from transmitter }
 bptr      : byteptr;           { fake pointer to pic   }

BEGIN

 Port[comMCR] := $03;           { PC <-> trans serial   }
                                { camera -> monitor     }

 Delay(200);                    { pause to stabilize    }

(*
 Write('Waiting for key press...');
 Readln;
*)

 bptr := Ptr(Seg(pic^),Ofs(pic^)-1);  { preset for loop }

(*
 Writeln('KeyPressed is: ',KeyPressed);
 Writeln('port end is:   ',(Port[comdata]=fldend));
*)

 SendByte(resol);               { specify resolution    }
 SendByte(XON);                 { prompt transmitter    }

 REPEAT                         { for each line         }
  bptr := Ptr(Seg(bptr^),Ofs(bptr^)+1);   { tick ptr    }
  WHILE ((Port[comLSR] AND DataReady) = 0) AND
        NOT KeyPressed DO;      { stall waiting         }
  bptr^ := Port[comdata];       { snag the byte         }
 UNTIL (bptr^ = fldend) OR KeyPressed;

(*
 Writeln('KeyPressed is: ',KeyPressed);
 Writeln('port end is:   ',(Port[comdata]=fldend));
 Writeln('data end is:   ',(bptr^=fldend));
*)

 Port[comMCR] := $00;           { PC <-> rec serial     }
                                { rec -> monitor        }

END;

{-------------------------------------------------------}
{ Save picture file on disk                             }
{ Uses the smallest number of blocks to fit the data    }

PROCEDURE SavePicture(filespec : strtype;
                      pic : picptr);
VAR
 ndx       : subrng;            { index into word array }
 rndx      : REAL;              {  real equivalent      }
 nblocks   : INTEGER;           { number of disk blocks }
 xfered    : INTEGER;           { number actually done  }

 pfile     : FILE;              { untyped file for I/O  }

BEGIN

 Writeln('Writing ',filespec);
 Assign(pfile,filespec);
 Rewrite(pfile);

 ndx := 0;                      { start with first word }

 Write('  Data length = ');
 WHILE (ndx < maxbuffer) AND    { WHILE not end of pic  }
       (Lo(pic^.words[ndx]) <> fldend) AND
       (Hi(pic^.words[ndx]) <> fldend) DO
   ndx := ndx + 1;

 ndx := ndx + 1;                { fix 0 origin          }

 rndx := 2.0 * ndx;             { allow >32K numbers... }
 Write(rndx:6:0,' bytes, file length = ');

 nblocks := ndx DIV 64;         { 64 words = 128 bytes  }

 IF (ndx MOD 64) <> 0           { partial block?        }
  THEN nblocks := nblocks + 1;

 rndx := 128.0 * nblocks;       { actual file size      }
 Writeln(rndx:6:0,' bytes');

 BlockWrite(pfile,pic^.words[0],nblocks,xfered);

 IF xfered <> nblocks           { completed?            }
  THEN BEGIN
   Writeln('Problem writing the file, error code: ',
            IOerror);
   Writeln('  Blocks computed: ',nblocks);
   Writeln('  Blocks written:  ',xfered);
  END;

END;


{-------------------------------------------------------}
{ Load picture file from disk                           }

PROCEDURE LoadPicture(filespec : strtype;
                      pic : picptr);

BEGIN

 Writeln('Reading ',filespec);
 Assign(picfile,filespec);

 {$I- turn off I/O checking                             }
 Reset(picfile);
 IOerror := IOresult;
 {$I+ turn on  I/O checking again                       }

 IF IOresult <> 0
  THEN BEGIN
   Writeln('Problem reading the file, IO error: ',
            IOerror);
   HALT;
  END;

 {$I- turn off I/O checking                             }
 Read(picfile,pic^);            { this does the read    }
 IOerror := IOresult;
 {$I+ turn on  I/O checking again                       }

 IF NOT (IOresult IN [0,$99])   { $99 = short block, OK }
  THEN BEGIN
   Writeln('Problem reading the file, IO error: ',
            IOerror);
   HALT;
  END;

END;


{-------------------------------------------------------}
{ Send picture to display                               }
{ Sets RTS and DTR to switch the relay box to ensure    }
{  a good connection                                    }

PROCEDURE SendPicture(pic : picptr);

VAR
 bptr      : byteptr;           { fake pointer to pic   }

BEGIN

 Port[comMCR] := $00;           { PC <-> rec serial     }
                                { rec -> monitor        }

 Delay(100);                    { pause to stabilize    }

 bptr := Ptr(Seg(pic^),Ofs(pic^)-1);  { set byte ptr    }

 REPEAT                         { for each line         }
  bptr := Ptr(Seg(bptr^),Ofs(bptr^)+1);   { tick ptr    }
  WHILE (Port[comdata] = XOFF) AND NOT KeyPressed DO;
  WHILE ((Port[comLSR] AND THRE) = 0) AND
        NOT KeyPressed DO;      { stall for data        }
  Port[comdata] := bptr^;       { send the byte         }
 UNTIL (bptr^ = fldend) OR KeyPressed;

END;


{-------------------------------------------------------}
{ Set up frame and line syncs in a buffer               }
{ This should be done only in freshly allocated buffers }

PROCEDURE SetSyncs(pic1 : picptr);

VAR
 lndx      : linerng;           { index into lines      }

BEGIN

 pic1^.fmt.syncF := fieldsync;  { set up empty picture  }

 FOR lndx := 0 TO maxline DO BEGIN
  pic1^.fmt.lines[lndx].syncL := linesync;
  FillChar(pic1^.fmt.lines[lndx].pels[0],maxpel+1,0);
 END;

 pic1^.fmt.syncE := fldend;     { set ending control    }

END;


{-------------------------------------------------------}
{ Decompress pic1 into pic2                             }

PROCEDURE Expand(pic1,pic2 : picptr);

CONST
 errthresh = 10;           { max errors in frame        }

VAR
 bptr      : ^byte;
 lndx      : linerng;
 pndx      : pelrng;
 overflow  : BOOLEAN;
 oldbyte   : BYTE;
 reps      : INTEGER;
 frametop  : BOOLEAN;
 giveup    : BOOLEAN;
 errcount  : INTEGER;

BEGIN

 bptr := Ptr(Seg(pic1^),Ofs(pic1^));

 SetSyncs(pic2);                { fill in the syncs     }

 lndx := 0;
 pndx := 0;

 frametop := TRUE;
 giveup := FALSE;
 errcount := 0;
 WHILE (bptr^ <> fldend) AND NOT giveup
 DO BEGIN { and now the data...   }
  CASE bptr^ OF
   fieldsync : BEGIN
            IF (lndx <> 0) OR (pndx <> 0)
             THEN BEGIN
              Writeln('Field sync found after data');
             END;
            oldbyte := 0;
            frametop := TRUE;
(*          Writeln('Field sync'); *)
           END;
   linesync : BEGIN
            IF (lndx < maxline) AND NOT frametop
             THEN lndx := lndx + 1
             ELSE frametop := false;
            oldbyte := 0;
            pndx := 0;
            overflow := FALSE;
(*          Write('.'); *)
           END;
   fldend : BEGIN               { can't get here...     }
             Writeln;
             Writeln('Surprise at having found field end!');
            END;
   ELSE BEGIN
    CASE (bptr^ AND $F0) OF
     $00..$3F : BEGIN
              pic2^.fmt.lines[lndx].pels[pndx] := bptr^;
              oldbyte := bptr^;
              IF pndx < maxpel
               THEN BEGIN
                pndx := pndx + 1;
                IF overflow
                 THEN BEGIN
                  Write('Too much data on line ',lndx:3);
                  Writeln('  pel data ',ByteToHex(bptr^));
                  errcount := Succ(errcount);
                 END;
               END
               ELSE BEGIN
                pndx := 0;
                overflow := TRUE;
               END;
(*            Writeln('Data: ',ByteToHex(bptr^)); *)
             END;
     rep1  : BEGIN
              FOR reps := 1 TO (bptr^ AND $0F) DO BEGIN
               pic2^.fmt.lines[lndx].pels[pndx] := oldbyte;
               IF pndx < maxpel
                THEN BEGIN
                 pndx := pndx + 1;
                 IF overflow
                  THEN BEGIN
                   Write('Too much data on line ',lndx:3);
                   Writeln('   1x rep ',ByteToHex(bptr^));
                   errcount := Succ(errcount);
(*                 pndx := 0; *)
                  END
                END
                ELSE BEGIN
                 pndx := 0;
                 overflow := TRUE;
                END;
(*             Writeln('Rep1: ',ByteToHex(bptr^)); *)
              END;
             END;
     rep16 : BEGIN
              FOR reps := 1 TO (16 * (bptr^ AND $0F)) DO BEGIN
               pic2^.fmt.lines[lndx].pels[pndx] := oldbyte;
               IF pndx < maxpel
                THEN BEGIN
                 pndx := pndx + 1;
                 IF overflow
                  THEN BEGIN
                   Write('Too much data on line ',lndx:3);
                   Writeln('  16x rep ',ByteToHex(bptr^));
                   errcount := Succ(errcount);
(*                 pndx := 0; *)
                  END
                END
                ELSE BEGIN
                 pndx := 0;
                 overflow := TRUE;
                END;
(*             Writeln('Rep16: ',ByteToHex(bptr^)); *)
              END;
             END;
     ELSE BEGIN
      Writeln('Garbage byte: ',ByteToHex(bptr^),
                  ' at line ',lndx,' pel ',pndx);
      errcount := Succ(errcount);
     END;
    END;
   END;
  END;
  IF errcount > errthresh
   THEN giveup := TRUE;
  bptr := Ptr(Seg(bptr^),Ofs(bptr^)+1);  { next input byte }
 END;

 IF giveup
  THEN BEGIN
   Writeln('Too many errors -- giving up!');
   HALT;
  END;

(* Writeln; *)

END;


{-------------------------------------------------------}
{ Drop current count into picture                       }
{ Ticks pointer by the number of bytes added in         }

PROCEDURE DoCount(reps : INTEGER;
                  VAR bptr : byteptr);

BEGIN

 IF reps >= 256
  THEN BEGIN
   bptr^ := rep16;              { default = 256         }
   bptr := Ptr(Seg(bptr^),Ofs(bptr^)+1);
   reps := reps - 256;          { fix the remainder     }
  END;


 IF (reps AND $F0) <> 0
  THEN BEGIN
   bptr^ := rep16 + (reps SHR 4);
   bptr := Ptr(Seg(bptr^),Ofs(bptr^)+1);
   reps := reps AND $0F;
  END;

 IF reps <> 0
  THEN BEGIN
   bptr^ := rep1 + reps;
   bptr := Ptr(Seg(bptr^),Ofs(bptr^)+1);
  END;

END;


{-------------------------------------------------------}
{ Compress pic1 into pic2                               }

PROCEDURE Compress(pic1,pic2 : picptr);

VAR
 bptr      : ^byte;
 lndx      : linerng;
 pndx      : pelrng;
 oldbyte   : BYTE;
 reps      : INTEGER;

BEGIN

{--- fill buffer with zeros to ensure no trash          }

 FillChar(pic2^.words[0],maxbuffer,0);
 FillChar(pic2^.words[maxbuffer DIV 2],maxbuffer,0);

 bptr := Ptr(Seg(pic2^),Ofs(pic2^));

 bptr^ := fieldsync;            { flag the start        }
 bptr := Ptr(Seg(bptr^),Ofs(bptr^)+1);

 FOR lndx := 0 TO maxline DO BEGIN
  bptr^ := linesync;            { flag new line         }
  bptr := Ptr(Seg(bptr^),Ofs(bptr^)+1);
  oldbyte := 0;
  reps := 0;                    { force leading zero    }

  FOR pndx := 0 TO maxpel DO BEGIN
   IF pic1^.fmt.lines[lndx].pels[pndx] = oldbyte
    THEN reps := reps + 1       { accumulate count      }
    ELSE BEGIN                  { new byte, send ...    }
     IF reps > 1
      THEN DoCount(reps,bptr);  { n reps, send count    }
     IF reps = 1                { 1 rep, copy old byte  }
      THEN BEGIN
       bptr^ := oldbyte;
       bptr := Ptr(Seg(bptr^),Ofs(bptr^)+1); { step ptr }
      END;

     bptr^ := pic1^.fmt.lines[lndx].pels[pndx]; { new   }
     bptr := Ptr(Seg(bptr^),Ofs(bptr^)+1);   { step ptr }
     reps := 0;                 { reset counter         }
     oldbyte := pic1^.fmt.lines[lndx].pels[pndx];
    END;
  END;

{--- send last count and trailing zero                  }

  IF reps > 1
   THEN DoCount(reps,bptr);     { n reps, send count    }
  IF reps = 1                   { 1 rep, copy old byte  }
   THEN BEGIN
    bptr^ := oldbyte;
    bptr := Ptr(Seg(bptr^),Ofs(bptr^)+1);    { step ptr }
   END;

  bptr^ := 0;                   { force trailer zero    }

(*Write('.'); *)

 END;

 bptr^ := fldend;               { flag the ending       }
 Writeln;

END;